(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

open XNum
open ALCoding
  
(* opaque type for dimensions *)
let apply_dim dim x =
  match !x with
  | VMTypes.Symbol s ->
      if s = sym_Base
      then ref (VMTypes.Number dim.Dim.d_base)
      else
        if s = sym_Stretch
        then
          ref
            (VMTypes.Tuple
               [| ref (VMTypes.Number dim.Dim.d_stretch_factor);
                 ref (VMTypes.Number (num_of_int dim.Dim.d_stretch_order))
               |])
        else
          if s = sym_StretchFactor
          then ref (VMTypes.Number dim.Dim.d_stretch_factor)
          else
            if s = sym_StretchOrder
            then ref (VMTypes.Number (num_of_int dim.Dim.d_stretch_order))
            else
              if s = sym_Shrink
              then
                ref
                  (VMTypes.Tuple
                     [| ref (VMTypes.Number dim.Dim.d_shrink_factor);
                       ref (VMTypes.Number (num_of_int dim.Dim.d_shrink_order))
                     |])
              else
                if s = sym_ShrinkFactor
                then ref (VMTypes.Number dim.Dim.d_shrink_factor)
                else
                  if s = sym_ShrinkOrder
                  then ref (VMTypes.Number (num_of_int dim.Dim.d_shrink_order))
                  else VMTypes.runtime_error "invalid argument"
  | _ -> VMTypes.runtime_error "invalid argument"
  
let cmp_dim = Dim.dim_equal
  
let (dim_wrapper, dim_unwrapper) =
  Opaque.declare_type "dimension" apply_dim cmp_dim cmp_dim
  
let wrap_dim dim = VMTypes.Opaque (dim_wrapper dim)
  
let unwrap_dim = decode_opaque "dimension" dim_unwrapper
  
(* primitives *)
let prim_make_dim args =
  match args with
  | [ base; st; st_ord; sh; sh_ord ] ->
      let a = Machine.decode_num "make_dim" base in
      let b = Machine.decode_num "make_dim" st in
      let c = decode_int "make_dim" st_ord in
      let d = Machine.decode_num "make_dim" sh in
      let e = decode_int "make_dim" sh_ord
      in
        wrap_dim
          {
            Dim.d_base = a;
            Dim.d_stretch_factor = b;
            Dim.d_stretch_order = c;
            Dim.d_shrink_factor = d;
            Dim.d_shrink_order = e;
          }
  | _ -> assert false
  
let prim_fixed_dim base =
  let x = Machine.decode_num "fixed_dim" base in wrap_dim (Dim.fixed_dim x)
  
let prim_dim_zero = wrap_dim Dim.dim_zero
  
let prim_dim_1pt = wrap_dim Dim.dim_1pt
  
let prim_dim_12pt = wrap_dim Dim.dim_12pt
  
let prim_dim_fil = wrap_dim Dim.dim_fil
  
let prim_dim_fill = wrap_dim Dim.dim_fill
  
let prim_dim_ss = wrap_dim Dim.dim_ss
  
let prim_dim_filneg = wrap_dim Dim.dim_filneg
  
let prim_dim_equal dim0 dim1 =
  let d0 = unwrap_dim "dim_equal" dim0 in
  let d1 = unwrap_dim "dim_equal" dim1 in VMTypes.Bool (Dim.dim_equal d0 d1)
  
let prim_dim_add dim0 dim1 =
  let d0 = unwrap_dim "dim_add" dim0 in
  let d1 = unwrap_dim "dim_add" dim1 in wrap_dim (Dim.dim_add d0 d1)
  
let prim_dim_neg dim =
  let d = unwrap_dim "dim_neg" dim in wrap_dim (Dim.dim_neg d)
  
let prim_dim_sub dim0 dim1 =
  let d0 = unwrap_dim "dim_sub" dim0 in
  let d1 = unwrap_dim "dim_sub" dim1 in wrap_dim (Dim.dim_sub d0 d1)
  
let prim_dim_mult x dim =
  let a = Machine.decode_num "dim_mult" x in
  let d = unwrap_dim "dim_mult" dim in wrap_dim (Dim.dim_mult a d)
  
let prim_dim_max dim0 dim1 =
  let d0 = unwrap_dim "dim_max" dim0 in
  let d1 = unwrap_dim "dim_max" dim1 in wrap_dim (Dim.dim_max d0 d1)
  
let prim_dim_min dim0 dim1 =
  let d0 = unwrap_dim "dim_min" dim0 in
  let d1 = unwrap_dim "dim_min" dim1 in wrap_dim (Dim.dim_min d0 d1)
  
let prim_dim_max_stretch dim =
  let d = unwrap_dim "dim_max_stretch" dim
  in VMTypes.Number (Dim.dim_max_stretch d)
  
let prim_dim_max_shrink dim =
  let d = unwrap_dim "dim_max_shrink" dim
  in VMTypes.Number (Dim.dim_max_shrink d)
  
let prim_dim_max_value dim =
  let d = unwrap_dim "dim_max_value" dim
  in VMTypes.Number (Dim.dim_max_value d)
  
let prim_dim_min_value dim =
  let d = unwrap_dim "dim_min_value" dim
  in VMTypes.Number (Dim.dim_min_value d)
  
let prim_dim_shift_base dim x =
  let d = unwrap_dim "dim_shift_base" dim in
  let y = Machine.decode_num "dim_shift_base" x
  in wrap_dim (Dim.dim_shift_base d y)
  
let prim_dim_shift_base_upto dim x =
  let d = unwrap_dim "dim_shift_base_upto" dim in
  let y = Machine.decode_num "dim_shift_base_upto" x
  in wrap_dim (Dim.dim_shift_base_upto d y)
  
let prim_dim_inc_upto dim x =
  let d = unwrap_dim "dim_inc_upto" dim in
  let y = Machine.decode_num "dim_inc_upto" x
  in wrap_dim (Dim.dim_inc_upto d y)
  
let prim_dim_dec_upto dim x =
  let d = unwrap_dim "dim_dec_upto" dim in
  let y = Machine.decode_num "dim_dec_upto" x
  in wrap_dim (Dim.dim_dec_upto d y)
  
let prim_dim_resize_upto dim x =
  let d = unwrap_dim "dim_resize_upto" dim in
  let y = Machine.decode_num "dim_resize_upto" x
  in wrap_dim (Dim.dim_resize_upto d y)
  
let prim_adjustment_ratio dim x =
  let d = unwrap_dim "dim_adjustment_ratio" dim in
  let y = Machine.decode_num "dim_adjustment_ratio" x in
  let (a, b) = Dim.adjustment_ratio d y
  in
    VMTypes.Tuple [| ref (VMTypes.Number a); ref (VMTypes.Number (num_of_int b)) |]
  
let prim_dim_scale_badness ratio =
  match !ratio with
  | VMTypes.Tuple [| x; y |] ->
      let a = Machine.decode_num "dim_scale_badness" x in
      let b = decode_int "dim_scale_badness" y
      in VMTypes.Number (Dim.dim_scale_badness (a, b))
  | _ -> VMTypes.runtime_error "dim_scale_badness: invalid argument"
  
let prim_dim_scale dim ratio =
  let d = unwrap_dim "dim_scale" dim
  in
    match !ratio with
    | VMTypes.Tuple [| y; z |] ->
        let a = Machine.decode_num "dim_scale" y in
        let b = decode_int "dim_scale" z in wrap_dim (Dim.dim_scale d (a, b))
    | _ -> VMTypes.runtime_error "dim_scale: invalid argument"
  
let prim_dim_scale_upto dim ratio =
  let d = unwrap_dim "dim_scale_upto" dim
  in
    match !ratio with
    | VMTypes.Tuple [| y; z |] ->
        let a = Machine.decode_num "dim_scale_upto" y in
        let b = decode_int "dim_scale_upto" z
        in wrap_dim (Dim.dim_scale_upto d (a, b))
    | _ -> VMTypes.runtime_error "dim_scale_upto: invalid argument"
  

